home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / ASM / READATOM.ASM < prev    next >
Encoding:
Assembly Source File  |  1993-10-14  |  14.6 KB  |  686 lines
  1. ;* READATOM.ASM
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Borland TASM code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Read an atom (interpreter support)            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: John Jensen        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 10 Feb 87:    fix to convert first char after # to upper case (tc)    *
  18. ;* - 10 Feb 87:    added support to do readline (tc)            *
  19. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  20. ;*                                    *
  21. ;*                    ``In nomine omnipotentii dei''    *
  22. ;************************************************************************
  23. IDEAL
  24. %PAGESIZE    60, 132
  25. MODEL    medium
  26. LOCALS    @@
  27.  
  28.     INCLUDE    "scheme.ash"
  29.     INCLUDE "interprt.ash"
  30.  
  31. COM    EQU    3bh
  32. BUFSIZE    EQU    256
  33. TEST_NUM EQU    8
  34. EOFERR    EQU    1
  35. SHARPERR EQU    7
  36. PORTERR    EQU    -2
  37. HEAPERR    EQU    -3
  38.  
  39. DATASEG
  40.  
  41. inv_char DB    "Invalid character constant", 0
  42. limit    DW    ?            ; current size of atom buffer
  43. main_reg DW    ?            ; main register
  44. flg_eof    DW    ?            ; whether to flag end-of-file
  45. atomb    DW    ?            ; atom buffer
  46. char    DB    20h            ; most recently received char
  47.  
  48. CODESEG
  49.  
  50. ;************************************************************************
  51. ; Set up for the operation of reading a single line from the given port.
  52. ;************************************************************************
  53. PROC C    sread_ln USES si di, @@portreg, @@page, @@disp
  54.     mov    ax, [@@portreg]
  55.     mov    [main_reg], ax
  56.     call    ssetadr C, [@@page], [@@disp]
  57.     or    ax, ax
  58.     jz    @@portok
  59.     mov    ax, PORTERR
  60.     call    errmsg C, ax
  61.     jmp    @@exit
  62. @@portok:
  63.     mov    [flg_eof], 1
  64.     call    rcvchar        ; get char, eof won't return here
  65.     jnc    @@readok
  66.     jmp    @@exit
  67. @@readok:
  68.     cmp    al, LF        ; is char linefeed? if so, restart
  69.     je    @@portok
  70.     or    al, al        ; is this the previous EOLN marker ?
  71.     je    @@portok
  72.  
  73.     push    ax
  74.     mov    ax, BUFSIZE    ; Get buffer size
  75.     mov    [limit], ax
  76.     call    malloc C, ax
  77.     or    ax, ax
  78.     jne    @@allocok
  79.     pop    ax        ; trash off
  80.     mov    ax, HEAPERR
  81.     call    abortread C, ax
  82.     jmp    @@exit
  83.  
  84. @@allocok:
  85.     mov    si, ax
  86.     mov    [atomb], ax    ; address of buffer
  87.     mov    [flg_eof], 0    ; don't flag error on EOF
  88.     xor    bx, bx        ; index into buffer
  89.     pop    ax
  90. @@readchar:
  91.     cmp    al, CR
  92.     je    @@done
  93.     cmp    al, CTRL_Z
  94.     je    @@done
  95.     cmp    al, LF
  96.     je    @@done
  97.  
  98.     call    addchar C, bx, ax ; Add character to buffer
  99.     or    ax, ax
  100.     jnz    @@exit
  101.     inc    bx
  102.     call    rcvchar
  103.     jc    @@exit
  104.     jmp    @@readchar
  105.  
  106. @@done:
  107.     mov    cx, STRTYPE    ; Allocate string data type
  108.     push    bx
  109.     call    alloc_block C, [main_reg], cx, bx
  110.     mov    cx, 3        ; Copy buffer to Scheme string
  111.     mov    si, [atomb]
  112.     pop    bx
  113.     call    toblock C, [main_reg], cx, si, bx
  114.     call    free C, [atomb]
  115.     mov    [flg_eof], 1    ; Reset flags
  116.     mov    [limit], 0
  117. @@exit:
  118.     ret
  119. ENDP    sread_ln
  120.  
  121. ;************************************************************************
  122. ;    Set up for the operation of reading a single atom from the given port.
  123. ;    Special characters such as ')' are parsed as lists(!) to tell them from
  124. ;    ordinary atoms.
  125. ;************************************************************************
  126. PROC C    sread_atom USES si di, @@portreg:WORD, @@page:WORD, @@disp:WORD
  127.     mov    ax, [@@portreg]
  128.     mov    [main_reg], ax
  129.     call    ssetadr C, [@@page], [@@disp]
  130.     or    ax, ax
  131.     jz    @@portok
  132.     mov    ax, PORTERR
  133.     call    errmsg C, ax
  134.     jmp    @@exit
  135. @@portok:
  136.     mov    [flg_eof], 1
  137.     mov    [limit], 0
  138. @@skipspaces:
  139.     call    rcvchar
  140.     jc    @@exit
  141.     call    ck_space
  142.     or    cx, cx
  143.     jz    @@skipspaces
  144.     cmp    al, ';'
  145.     jne    @@dothejob
  146. @@comment:
  147.     call    rcvchar
  148.     jc    @@exit
  149.     cmp    al, CR
  150.     jne    @@comment
  151.     jmp    @@skipspaces
  152. @@dothejob:
  153.     or    al, al            ; null character?
  154.     jz    @@skipspaces
  155.     call    read_atom C
  156. @@exit:
  157.     ret
  158. ENDP    sread_atom
  159.  
  160. ;************************************************************************
  161. ;        Fetch one character from the input stream
  162. ;************************************************************************
  163. PROC    rcvchar    NEAR
  164.     push    bx cx dx
  165.     call    take_ch C        ; takechar()
  166.     pop    dx cx bx
  167.     cmp    ax, 256            ; Check the character
  168.     jge    @@fail
  169.     cmp    al, CTRL_Z        ; EOF character?
  170.     je    @@fail
  171.     mov    [char], al
  172.     clc                ; no carry = success
  173.     ret
  174. @@fail:                    ; EOF character is fetched
  175.     cmp    [flg_eof], 0        ; EOF flag set?
  176.     jne    @@error
  177.     mov    ax, CTRL_Z
  178.     mov    [char], al
  179.     clc                ; no carry = success
  180.     ret
  181. @@error:
  182.     mov    ax, EOFERR
  183.     call    abortread C, ax
  184.     stc                ; carry = defeat
  185.     ret
  186. ENDP    rcvchar
  187.  
  188. ;************************************************************************
  189. ;         Read in an atom (symbol, string, number)
  190. ;    Store the pointer to the atom in REG.
  191. ;    Special characters such as ')' or ',' are read as atoms themselves.
  192. ;    Normal atoms will end in a whitespace or a terminating macro character;
  193. ;    strings end with the closing    '"'.
  194. ;    Numbers in the requested base are interpreted as such.
  195. ;    On exit, the next character in the buffer is the one following the last
  196. ;    character of the atom.
  197. ;************************************************************************
  198. PROC C    read_atom NEAR
  199.     LOCAL    @@biglimit, @@big, @@flo:QWORD, @@escaped, @@char, @@numbase, @@status
  200.  
  201.     mov    di, ax            ; save the char just read
  202.     xor    cx, cx
  203.     mov    [flg_eof], cx        ; initialization
  204.     mov    [@@char], cx
  205.     mov    [@@escaped], cx
  206.     mov    [@@status], cx
  207.     mov    [@@numbase], 10
  208.     mov    ax, BUFSIZE
  209.     mov    [limit], ax
  210.     call    malloc C, ax        ; allocate memory
  211.     or    ax, ax
  212.     jne    @@memok
  213. @@memerr:
  214.     mov    ax, HEAPERR
  215.     call    abortread C, ax
  216.     jmp    @@ret
  217. @@memok:
  218.     mov    si, ax
  219.     mov    [atomb], ax        ; save the address of atom buffer
  220.     mov    ax, di
  221.     mov    di, [main_reg]
  222.     xor    bx, bx
  223.     cmp    al, '['            ; check for special characters first
  224.     je    @@special
  225.     cmp    al, ']'
  226.     je    @@special
  227.     cmp    al, '{'
  228.     je    @@special
  229.     cmp    al, '}'
  230.     je    @@special
  231.     cmp    al, '('
  232.     je    @@special
  233.     cmp    al, ')'
  234.     je    @@special
  235.     cmp    al, ''''
  236.     je    @@special
  237.     cmp    al, '`'
  238.     jne    @@string
  239. @@special:
  240.     mov    [si], al        ; *atomb = ch
  241.     inc    bx
  242.     jmp    @@donespecial
  243.  
  244. @@string:
  245.     cmp    al, '"'
  246.     jne    @@comma
  247.     call    delimby C, ax        ; get the string
  248.     jnc    @@stringend
  249.     jmp    @@bye            ; eof occured
  250. @@stringend:
  251.     push    bx
  252.     mov    cx, STRTYPE
  253.     call    alloc_block C, [main_reg], cx, bx
  254.     mov    cx, 3
  255.     mov    si, [atomb]
  256.     pop    bx
  257.     call    toblock C, [main_reg], cx, si, bx
  258.     jmp    @@bye
  259.  
  260. @@comma:
  261.     cmp    al, ','
  262.     jne    @@macro
  263.     mov    [si], al
  264.     inc    bx
  265.     call    rcvchar
  266.     jnc    @@commaok
  267.     jmp    @@bye
  268. @@commaok:
  269.     cmp    al, '@'
  270.     je    @@commaspecial
  271.     cmp    al, '.'
  272.     je    @@commaspecial
  273.     jmp    @@donenormal
  274. @@commaspecial:
  275.     mov    [si+bx], al
  276.     inc    bx
  277.     jmp    @@donespecial
  278.  
  279. @@macro:
  280.     cmp    al, '#'
  281.     je    @@itsamacro
  282.     jmp    @@symbol
  283. @@itsamacro:
  284.     mov    [flg_eof], 1
  285. @@integerloop:
  286.     or    bx, bx    ; first character?
  287.     jz    @@macrofirst
  288. @@rathersymbol:
  289.     jmp    @@alsosymbol
  290. @@macrofirst:
  291.     cmp    al, '#'
  292.     jne    @@rathersymbol
  293.     call    rcvchar
  294.     jnc    @@macrook
  295.     jmp    @@bye
  296. @@macrook:
  297.     call    ck_space
  298.     or    cx, cx
  299.     jnz    @@macrostillok
  300. @@macroerror:
  301.     mov    ax, SHARPERR
  302.     call    abortread C, ax
  303.     jmp    @@bye
  304. @@macrostillok:
  305.     mov    [si+1], al        ; save the character
  306.     push    bx
  307.     lea    bx, [locases]
  308.     xlat
  309.     pop    bx
  310.     cmp    al, 'b'
  311.     jne    @@decimal
  312.     mov    [@@numbase], 2
  313.     jmp    @@nextinteger
  314. @@decimal:
  315.     cmp    al, 'd'
  316.     jne    @@hexadecimal
  317.     mov    [@@numbase], 10
  318.     jmp    @@nextinteger
  319. @@hexadecimal:
  320.     cmp    al, 'x'
  321.     je    @@itsahex
  322.     cmp    al, 'h'
  323.     jne    @@octal
  324. @@itsahex:
  325.     mov    [@@numbase], 16
  326.     jmp    @@nextinteger
  327. @@octal:
  328.     cmp    al, 'o'
  329.     jne    @@donebase
  330.     mov    [@@numbase], 8
  331.     jmp    @@nextinteger
  332.  
  333. @@donebase:
  334.     cmp    al, '\'
  335.     jne    @@modifier
  336.     call    rcvchar
  337.     jnc    @@baseok
  338. @@baseerror:
  339.     jmp    @@bye
  340. @@baseok:
  341.     call    addchar C, bx, ax
  342.     or    ax, ax
  343.     jnz    @@baseerror
  344.     inc    bx
  345.     mov    [@@char], 1
  346.     mov    [@@escaped], 1
  347.     jmp    @@nextinteger
  348.  
  349. @@modifier:
  350.     cmp    al, 'i'
  351.     je    @@nextinteger
  352.     cmp    al, 'e'
  353.     je    @@nextinteger
  354.     cmp    al, 's'
  355.     je    @@nextinteger
  356.     cmp    al, 'l'
  357.     je    @@nextinteger
  358.     cmp    al, '<'
  359.     je    @@tomacroerror
  360.     cmp    al, ')'
  361.     jne    @@modifierok
  362. @@tomacroerror:
  363.     jmp    @@macroerror
  364. @@modifierok:
  365.     mov    [BYTE si], '#'
  366.     lea    bx, [hicases]
  367.     xlat
  368.     mov    [si+1], al        ; Change letter past # to upper case
  369.     mov    bx, 2
  370.     cmp    al, '('
  371.     jne    @@nextinteger
  372.     jmp    @@donespecial
  373. @@nextinteger:
  374.     call    rcvchar
  375.     jnc    @@integerok
  376.     jmp    @@bye
  377. @@integerok:
  378.     jmp    @@integerloop
  379.  
  380. @@alsosymbol:
  381.     mov    [flg_eof], 0
  382. @@symbol:
  383.     call    ck_space        ; check for space
  384.     or    cx, cx
  385.     jz    @@symbolend
  386.     cmp    al, CTRL_Z        ; eof character?
  387.     je    @@symbolend
  388.     cmp    al, '('
  389.     je    @@symbolend
  390.     cmp    al, ')'
  391.     je    @@symbolend
  392.     cmp    al, ''''
  393.     je    @@symbolend
  394.     cmp    al, '`'
  395.     je    @@symbolend
  396.     cmp    al, COM
  397.     je    @@symbolend
  398.     cmp    al, ','
  399.     je    @@symbolend
  400.     cmp    al, '"'
  401.     je    @@symbolend
  402.     cmp    al, '['
  403.     je    @@symbolend
  404.     cmp    al, ']'
  405.     je    @@symbolend
  406.     cmp    al, '{'
  407.     je    @@symbolend
  408.     cmp    al, '}'
  409.     je    @@symbolend
  410.     push    bx
  411.     lea    bx, [hicases]
  412.     xlat
  413.     pop    bx
  414.     cmp    al, '|'
  415.     jne    @@not@@escaped
  416.     mov    [@@escaped], 1
  417.     call    delimby C, ax        ; read the whole symbol
  418.     jnc    @@symbolnext
  419.     jmp    @@bye
  420. @@not@@escaped:
  421.     cmp    al, '\'
  422.     jne    @@stillnot@@escaped
  423.     mov    [@@escaped], 1
  424.     mov    [flg_eof], 1
  425.     call    rcvchar
  426.     jnc    @@symbolok
  427. @@symbolerror:
  428.     jmp    @@bye            ; if carry flag set, force exit
  429. @@symbolok:
  430.     mov    [flg_eof], 0
  431. @@stillnot@@escaped:
  432.     call    addchar C, bx, ax
  433.     or    ax, ax
  434.     jnz    @@symbolerror
  435.     inc    bx
  436. @@symbolnext:
  437.     call    rcvchar            ; get the next character
  438.     jc    @@symbolerror
  439.     jmp    @@symbol
  440.  
  441. @@symbolend:
  442.     xor    al, al            ; put null at end of token
  443.     call    addchar C, bx, ax
  444.     or    ax, ax
  445.     jnz    @@symbolerror
  446.  
  447.     cmp    bx, 1            ; Check for single, un@@escaped dot
  448.     jne    @@number
  449.     cmp    [BYTE si], '.'
  450.     jne    @@number
  451.     cmp    [@@escaped], 1
  452.     je    @@number
  453.     jmp    @@donenormal
  454. @@number:                ; A token has been read, check for number
  455.     push    bx
  456.     call    scannum C, si, [@@numbase]
  457.     mov    si, [atomb]
  458.     pop    bx
  459.     or    ax, ax    ; number or not?
  460.     jnz    @@thinkso
  461.     jmp    @@donecharorinterned
  462. @@thinkso:
  463.     cmp    [@@escaped], 1
  464.     jne    @@believeso
  465.     jmp    @@donecharorinterned
  466. @@believeso:
  467.     or    ax, ax            ; floating-point ?
  468.     jle    @@floatingpoint
  469.     add    ax, 9            ; (ax + 9) / 2
  470.     shr    ax, 1            ; ax = bytes needed for integer
  471.     mov    [@@biglimit], ax        ; save for later
  472.     call    malloc C, ax        ; allocate memory for @@big
  473.     or    ax, ax
  474.     jne    @@numberok
  475.     jmp    @@memerr
  476. @@numberok:
  477.     mov    bx, ax
  478.     mov    [@@big], ax
  479.     mov    [WORD bx+3], 0
  480.     call    buildint C, bx, [atomb], [@@numbase]
  481.     mov    di, [main_reg]
  482.     mov    bx, [@@big]
  483.     call    alloc_int C, di, bx
  484.     call    free C, [@@big]
  485.     jmp    @@done
  486.  
  487. @@floatingpoint:
  488.     lea    dx, [@@flo]
  489.     call    scanflo C, si, dx, [@@numbase]
  490.     mov    di, [main_reg]
  491.     lea    bx, [@@flo]
  492.     call    alloc_flonum C, di, [WORD bx], [WORD bx+2], [WORD bx+4], [WORD bx+6]
  493.     jmp    @@done
  494.  
  495. @@donecharorinterned:
  496.     cmp    [@@char], 0        ; #\ macro?
  497.     mov    di, [main_reg]
  498.     jne    @@donechar
  499.     jmp    @@donesymbol
  500. @@donechar:
  501.     mov    [(REG di).page], SPECCHAR*2
  502.     cmp    bx, 1            ; only one character?
  503.     jne    @@multichar
  504.     xor    ah, ah
  505.     mov    al, [si]
  506.     mov    [(REG di).disp], ax
  507.     jmp    @@done
  508. @@multichar:
  509.     mov    al, [si]
  510.     lea    bx, [hicases]
  511.     xlat
  512.     mov    [si], al
  513.     xor    bx, bx
  514. @@multiloop:
  515.     cmp    bl, SPECIALCHARS*2    ; finish the comparison?
  516.     je    @@multierror
  517.     mov    cx, bx
  518.     mov    di, [spchars+bx]
  519.     xor    bx, bx
  520. @@multianother:
  521.     mov    al, [di+bx+1]        ; get the character in string
  522.     cmp    al, 0            ; end of string
  523.     je    @@multiend
  524.     cmp    [si+bx], al
  525.     jne    @@multinext
  526.     inc    bx
  527.     jmp    @@multianother
  528. @@multiend:
  529.     mov    al, [di]
  530.     mov    di, [main_reg]
  531.     mov    [(REG di).disp], ax
  532.     jmp    @@done
  533.  
  534. @@multinext:
  535.     mov    bx, cx
  536.     inc    bx
  537.     inc    bx
  538.     jmp    @@multiloop
  539.  
  540. @@multierror:
  541.     mov    di, [main_reg]
  542.     mov    [(REG di).disp], '?'
  543.     mov    [@@status], -1
  544.     jmp    @@done
  545.  
  546. @@donesymbol:
  547.     call    intern C, di, si, bx
  548.     jmp    @@done
  549.  
  550. @@donespecial:
  551.     call    intern C, di, si, bx
  552.     lea    bx, [nil_reg]
  553.     mov    di, [main_reg]
  554.     call    cons C, di, di, bx
  555.     jmp    @@bye
  556.  
  557. @@donenormal:
  558.     call    intern C, di, si, bx
  559.     lea    bx, [nil_reg]
  560.     mov    di, [main_reg]
  561.     call    cons C, di, di, bx
  562. @@done:
  563.     cmp    [char], CTRL_Z        ; EOF character?
  564.     je    @@bye
  565.     call    pushchar C        ; put post-atom char back to buffer
  566. @@bye:
  567.     call    free C, [atomb]        ; release memory
  568.     mov    [flg_eof], 1        ; reset flags
  569.     mov    [limit], 0
  570.     mov    ax, [@@status]
  571. @@ret:
  572.     ret
  573. ENDP    read_atom
  574.  
  575. ;************************************************************************
  576. ;                DELIMBY(c)
  577. ;    DELIMBY takes characters from the input stream and places them
  578. ; in the buffer ATOMB, starting at offset stored in bx register, and
  579. ; ending when the delimiting character C is reached.
  580. ; Note:    si = address of atomb
  581. ;        bx = number of characters in atomb
  582. ;************************************************************************
  583. PROC C    delimby, @@char:WORD
  584.     mov    [flg_eof], 1        ; signal the EOF error
  585.     call    rcvchar
  586.     jc    @@exit
  587. @@loop:
  588.     cmp    al, [BYTE @@char]    ; reach the end?
  589.     je    @@done
  590.     or    al, al
  591.     jz    @@skip            ; strings are null-terminated. we drop this
  592.     cmp    al, '\'
  593.     jne    @@notescaped
  594.     call    rcvchar
  595.     jc    @@exit
  596. @@notescaped:
  597.     call    addchar C, bx, ax
  598.     or    ax, ax
  599.     jnz    @@exit
  600.     inc    bx
  601. @@skip:
  602.     call    rcvchar
  603.     jc    @@exit
  604.     jmp    @@loop
  605. @@done:
  606.     mov    [flg_eof], 0
  607. @@exit:
  608.     ret
  609. ENDP    delimby
  610.  
  611. ;************************************************************************
  612. ;             ADDCHAR (i, c)
  613. ;        ADDCHAR takes the character c and places it in the dynamic
  614. ;     atom buffer atomb, at offset i. If the buffer can not contain
  615. ;     any more characters, additional space is allocated, and limit
  616. ;     is adjusted accordingly.
  617. ;************************************************************************
  618. PROC C    addchar, @@index:WORD, @@char:WORD
  619.     mov    bx, [@@index]
  620.     cmp    bx, [limit]
  621.     jl    @@roomleft
  622.  
  623.     add    [limit], BUFSIZE
  624.     call    realloc C, [atomb], [limit]
  625.     or    ax, ax
  626.     jne    @@memok
  627.     mov    ax, HEAPERR
  628.     call    abortread C, ax
  629.     mov    ax, -1            ; ax = -1 for error
  630.     jmp    @@ret
  631. @@memok:
  632.     mov    [atomb], ax
  633.     mov    si, ax
  634.     mov    bx, [@@index]
  635. @@roomleft:
  636.     mov    ax, [@@char]
  637.     mov    [si+bx], al
  638.     xor    ax, ax            ; clear ax for success
  639. @@ret:
  640.     ret
  641. ENDP    addchar
  642.  
  643. ;************************************************************************
  644. ;            ABORTREAD(code)
  645. ;    Cancels the entire read operation (should exit after it), after
  646. ; resetting some vital registers.
  647. ; Note:    di = address of main register
  648. ;************************************************************************
  649. PROC C    abortread, errcode:WORD
  650.     mov    di, [main_reg]
  651.     cmp    [errcode], EOFERR
  652.     jne    @@generic
  653.     mov    [(REG di).page], EOF_PAGE*2
  654.     mov    [(REG di).disp], EOF_DISP
  655.     jmp    @@done
  656.  
  657. @@generic:
  658.     xor    ax, ax
  659.     mov    [(REG di).page], ax ; NUL main register
  660.     mov    [(REG di).disp], ax
  661. @@done:
  662.     call    errmsg C, [errcode]
  663.     ret
  664. ENDP    abortread
  665.  
  666. ;**********************************************************************
  667. ;     Local support to check the character in ax is space or not
  668. ;    Note:    cx = 0 iff the character is whitespace
  669. ;**********************************************************************
  670. PROC    ck_space NEAR
  671.     xor    cx, cx
  672.     cmp    al, SPACE
  673.     je    @@yup
  674.     cmp    al, TAB
  675.     jb    @@nope
  676.     cmp    al, CR
  677.     jbe    @@yup
  678. @@nope:
  679.     inc    cx
  680. @@yup:
  681.     ret
  682. ENDP    ck_space
  683.  
  684.     END
  685.  
  686.